home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / weyl / weyl_lsp.lha / algebraic-extension.lisp < prev    next >
Encoding:
Text File  |  1991-10-02  |  3.8 KB  |  94 lines
  1. ;;; -*- Mode:Lisp; Package:Weyli; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2. ;;; ===========================================================================
  3. ;;;                  Finite Algebraic Extension
  4. ;;; ===========================================================================
  5. ;;; (c) Copyright 1989, 1991 Cornell University
  6.  
  7. ;; $Id: algebraic-extension.lisp,v 2.8 1991/10/02 17:46:06 rz Exp $
  8.  
  9. (in-package "WEYLI")
  10.  
  11. (define-domain-creator algebraic-extension
  12.     ((coefficient-domain integral-domain) variables)
  13.   (make-instance 'algebraic-extension-ring
  14.          :variables (loop for var in variables
  15.                   collect (coerce var *general*))
  16.          :coefficient-domain coefficient-domain)
  17.   :predicate
  18.   (lambda (d)       ;; FIXTHIS: the predicate needs to be improved
  19.     (and (typep d 'algebraic-extension-ring)
  20.      (eql (coefficient-domain d) coefficient-domain)
  21.      (equal (ring-variables d) variables))))
  22.  
  23. ;; Use the polynomial print-object method for now
  24.  
  25. ;; This returns the term list for the minimal polynomial of the main
  26. ;; variable of the polynomial.  This polynomial is expected to be monic.
  27. (defmacro variable-minimal-polynomial (domain var)
  28.   `(get-variable-number-property ,domain (poly-order-number ,var)
  29.                  :minimal-polynomial))
  30.  
  31. (defmethod minimal-polynomial ((domain algebraic-extension-ring) variable)  
  32.   (with-slots (variables) domain
  33.     (unless (member variable variables :test #'equal)
  34.       (error "~'i~A~ is not a variable of ~S" variable domain)))
  35.   (get-variable-number-property domain (variable-index domain variable)
  36.                 :minimal-polynomial))
  37.  
  38. (defmethod minimal-polynomial
  39.     ((domain algebraic-extension-ring) (variable integer))  
  40.   (get-variable-number-property domain variable :minimal-polynomial))
  41.  
  42. (defmethod set-minimal-polynomial
  43.        ((domain algebraic-extension-ring) variable minimal-polynomial)
  44.   (setq variable (coerce variable *general*))
  45.   (with-slots (variables) domain    
  46.     (unless (member variable variables :test #'equal)
  47.       (error "~'i~A~ is not a variable of ~S" variable domain)))
  48.   (unless (eql (domain-of minimal-polynomial) domain)
  49.     (error "The algebraic relation ~S is not an element of ~S" 
  50.        minimal-polynomial domain))
  51.   (let ((poly-form (poly-form minimal-polynomial))
  52.     (var-index (variable-index domain variable)))
  53.     (unless (= var-index (poly-order-number poly-form))
  54.       (error "~S is not the most main variable of ~S"
  55.          (with-output-to-string (string)
  56.            (display variable string))
  57.            minimal-polynomial))
  58.     (setf (get-variable-number-property domain var-index :minimal-polynomial)
  59.       (poly-terms poly-form))))
  60.  
  61. (defsetf minimal-polynomial set-minimal-polynomial)
  62.  
  63. (defmethod make-polynomial ((domain algebraic-extension-ring) form)
  64.   (make-instance 'algebraic-object :domain domain :form form))
  65.  
  66. (defmethod-binary times algebraic-object (x y)
  67.   (bind-domain-context domain
  68.     (make-polynomial domain (alg-poly-times (poly-form x) (poly-form y)))))
  69.  
  70. (defun alg-poly-times (x y)
  71.   (cond ((poly-coef? x)
  72.      (if (poly-coef? y) (* x y)
  73.          (poly-simp y (terms-mon-times (poly-terms y) (e0) x))))
  74.     ((poly-coef? y)
  75.      (poly-simp x (terms-mon-times (poly-terms x) (e0) y)))
  76.     ((same-variable? x y)
  77.      (let ((min-poly (minimal-polynomial *domain* (poly-order-number x))))
  78.        (poly-simp x (if min-poly
  79.                 (terms-pseudo-remainder
  80.                  (terms-times (poly-terms x) (poly-terms y))
  81.                  min-poly)
  82.                 (terms-times (poly-terms x) (poly-terms y))))))
  83.     ((more-main? x y)
  84.      (poly-simp x (terms-mon-times (poly-terms x) (e0) y)))
  85.     (t (poly-simp y (terms-mon-times (poly-terms y) (e0) x)))))
  86.  
  87. (defmethod expt ((base algebraic-object) (expt integer))
  88.   (let ((domain (domain-of base)))
  89.     (bind-domain-context domain
  90.       (make-polynomial domain
  91.                (%funcall (repeated-squaring #'alg-poly-times
  92.                             (one *coefficient-domain*))
  93.                      (poly-form base) expt)))))
  94.